home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / srctran.lisp < prev    next >
Encoding:
Text File  |  1992-12-09  |  52.5 KB  |  1,607 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: srctran.lisp,v 1.38 92/08/05 00:27:15 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains macro-like source transformations which convert
  15. ;;; uses of certain functions into the canonical form desired within the
  16. ;;; compiler.  ### and other IR1 transforms and stuff.  Some code adapted from
  17. ;;; CLC, written by Wholey and Fahlman.
  18. ;;;
  19. ;;; Written by Rob MacLachlan
  20. ;;;
  21. (in-package "C")
  22.  
  23. ;;; Source transform for Not, Null  --  Internal
  24. ;;;
  25. ;;;    Convert into an IF so that IF optimizations will eliminate redundant
  26. ;;; negations.
  27. ;;;
  28. (def-source-transform not (x) `(if ,x nil t))
  29. (def-source-transform null (x) `(if ,x nil t))
  30.  
  31. ;;; Source transform for Endp  --  Internal
  32. ;;;
  33. ;;;    Endp is just NULL with a List assertion.
  34. ;;;
  35. (def-source-transform endp (x) `(null (the list ,x)))
  36.  
  37. ;;; We turn Identity into Prog1 so that it is obvious that it just returns the
  38. ;;; first value of its argument.  Ditto for Values with one arg.
  39. (def-source-transform identity (x) `(prog1 ,x))
  40. (def-source-transform values (x) `(prog1 ,x))
  41.  
  42. ;;; CONSTANTLY source transform  --  Internal
  43. ;;;
  44. ;;;    Bind the values and make a closure that returns them.
  45. ;;;
  46. (def-source-transform constantly (value &rest values)
  47.   (let ((temps (loop repeat (1+ (length values))
  48.              collect (gensym)))
  49.     (dum (gensym)))
  50.     `(let ,(loop for temp in temps and
  51.              value in (list* value values)
  52.              collect `(,temp ,value))
  53.        #'(lambda (&rest ,dum)
  54.        (declare (ignore ,dum))
  55.        (values ,@temps)))))
  56.  
  57.  
  58. ;;; COMPLEMENT IR1 transform  --  Internal
  59. ;;;
  60. ;;;    If the function has a known number of arguments, then return a lambda
  61. ;;; with the appropriate fixed number of args.  If the destination is a
  62. ;;; FUNCALL, then do the &REST APPLY thing, and let MV optimization figure
  63. ;;; things out.
  64. ;;;
  65. (deftransform complement ((fun) * * :node node)
  66.   "open code"
  67.   (multiple-value-bind (min max)
  68.                (function-type-nargs (continuation-type fun))
  69.     (cond
  70.      ((and min (eql min max))
  71.       (let ((dums (loop repeat min collect (gensym))))
  72.     `#'(lambda ,dums (not (funcall fun ,@dums)))))
  73.      ((let* ((cont (node-cont node))
  74.          (dest (continuation-dest cont)))
  75.     (and (combination-p dest)
  76.          (eq (combination-fun dest) cont)))
  77.       '#'(lambda (&rest args)
  78.        (not (apply fun args))))
  79.      (t
  80.       (give-up "Function doesn't have fixed argument count.")))))
  81.  
  82.  
  83. ;;;; List hackery:
  84.  
  85. ;;;
  86. ;;; Translate CxxR into car/cdr combos.
  87. (def-source-transform caar (x) `(car (car ,x)))
  88. (def-source-transform cadr (x) `(car (cdr ,x)))
  89. (def-source-transform cdar (x) `(cdr (car ,x)))
  90. (def-source-transform cddr (x) `(cdr (cdr ,x)))
  91. (def-source-transform caaar (x) `(car (car (car ,x))))
  92. (def-source-transform caadr (x) `(car (car (cdr ,x))))
  93. (def-source-transform cadar (x) `(car (cdr (car ,x))))
  94. (def-source-transform caddr (x) `(car (cdr (cdr ,x))))
  95. (def-source-transform cdaar (x) `(cdr (car (car ,x))))
  96. (def-source-transform cdadr (x) `(cdr (car (cdr ,x))))
  97. (def-source-transform cddar (x) `(cdr (cdr (car ,x))))
  98. (def-source-transform cdddr (x) `(cdr (cdr (cdr ,x))))
  99. (def-source-transform caaaar (x) `(car (car (car (car ,x)))))
  100. (def-source-transform caaadr (x) `(car (car (car (cdr ,x)))))
  101. (def-source-transform caadar (x) `(car (car (cdr (car ,x)))))
  102. (def-source-transform caaddr (x) `(car (car (cdr (cdr ,x)))))
  103. (def-source-transform cadaar (x) `(car (cdr (car (car ,x)))))
  104. (def-source-transform cadadr (x) `(car (cdr (car (cdr ,x)))))
  105. (def-source-transform caddar (x) `(car (cdr (cdr (car ,x)))))
  106. (def-source-transform cadddr (x) `(car (cdr (cdr (cdr ,x)))))
  107. (def-source-transform cdaaar (x) `(cdr (car (car (car ,x)))))
  108. (def-source-transform cdaadr (x) `(cdr (car (car (cdr ,x)))))
  109. (def-source-transform cdadar (x) `(cdr (car (cdr (car ,x)))))
  110. (def-source-transform cdaddr (x) `(cdr (car (cdr (cdr ,x)))))
  111. (def-source-transform cddaar (x) `(cdr (cdr (car (car ,x)))))
  112. (def-source-transform cddadr (x) `(cdr (cdr (car (cdr ,x)))))
  113. (def-source-transform cdddar (x) `(cdr (cdr (cdr (car ,x)))))
  114. (def-source-transform cddddr (x) `(cdr (cdr (cdr (cdr ,x)))))
  115.  
  116. ;;;
  117. ;;; Turn First..Fourth and Rest into the obvious synonym, assuming whatever is
  118. ;;; right for them is right for us.  Fifth..Tenth turn into Nth, which can be
  119. ;;; expanded into a car/cdr later on if policy favors it.
  120. (def-source-transform first (x) `(car ,x))
  121. (def-source-transform rest (x) `(cdr ,x))
  122. (def-source-transform second (x) `(cadr ,x))
  123. (def-source-transform third (x) `(caddr ,x))
  124. (def-source-transform fourth (x) `(cadddr ,x))
  125. (def-source-transform fifth (x) `(nth 4 ,x))
  126. (def-source-transform sixth (x) `(nth 5 ,x))
  127. (def-source-transform seventh (x) `(nth 6 ,x))
  128. (def-source-transform eighth (x) `(nth 7 ,x))
  129. (def-source-transform ninth (x) `(nth 8 ,x))
  130. (def-source-transform tenth (x) `(nth 9 ,x))
  131.  
  132.  
  133. ;;;
  134. ;;; Translate RPLACx to LET and SETF.
  135. (def-source-transform rplaca (x y)
  136.   (once-only ((n-x x))
  137.     `(progn
  138.        (setf (car ,n-x) ,y)
  139.        ,n-x)))
  140. ;;;
  141. (def-source-transform rplacd (x y)
  142.   (once-only ((n-x x))
  143.     `(progn
  144.        (setf (cdr ,n-x) ,y)
  145.        ,n-x)))
  146.  
  147.  
  148. (def-source-transform nth (n l) `(car (nthcdr ,n ,l)))
  149.   
  150. (defvar *default-nthcdr-open-code-limit* 6)
  151. (defvar *extreme-nthcdr-open-code-limit* 20)
  152.  
  153. (deftransform nthcdr ((n l) (unsigned-byte t) * :node node)
  154.   "convert NTHCDR to CAxxR"
  155.   (unless (constant-continuation-p n) (give-up))
  156.   (let ((n (continuation-value n)))
  157.     (when (> n
  158.          (if (policy node (= speed 3) (= space 0))
  159.          *extreme-nthcdr-open-code-limit*
  160.          *default-nthcdr-open-code-limit*))
  161.       (give-up))
  162.  
  163.     (labels ((frob (n)
  164.            (if (zerop n)
  165.            'l
  166.            `(cdr ,(frob (1- n))))))
  167.       (frob n))))
  168.  
  169.  
  170. ;;;; ARITHMETIC and NUMEROLOGY.
  171.  
  172. (def-source-transform plusp (x) `(> ,x 0))
  173. (def-source-transform minusp (x) `(< ,x 0))
  174. (def-source-transform zerop (x) `(= ,x 0))
  175.  
  176. (def-source-transform 1+ (x) `(+ ,x 1))
  177. (def-source-transform 1- (x) `(- ,x 1))
  178.  
  179. (def-source-transform oddp (x) `(not (zerop (logand ,x 1))))
  180. (def-source-transform evenp (x) `(zerop (logand ,x 1)))
  181.  
  182. ;;; Note that all the integer division functions are available for inline
  183. ;;; expansion.
  184.  
  185. (macrolet ((frob (fun)
  186.          `(def-source-transform ,fun (x &optional (y nil y-p))
  187.         (declare (ignore y))
  188.         (if y-p
  189.             (values nil t)
  190.             `(,',fun ,x 1)))))
  191.   (frob truncate)
  192.   (frob round))
  193.  
  194. (def-source-transform lognand (x y) `(lognot (logand ,x ,y)))
  195. (def-source-transform lognor (x y) `(lognot (logior ,x ,y)))
  196. (def-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
  197. (def-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
  198. (def-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
  199. (def-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
  200. (def-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
  201. (def-source-transform logbitp (index integer)
  202.   `(not (zerop (logand (ash 1 ,index) ,integer))))
  203. (def-source-transform byte (size position) `(cons ,size ,position))
  204. (def-source-transform byte-size (spec) `(car ,spec))
  205. (def-source-transform byte-position (spec) `(cdr ,spec))
  206. (def-source-transform ldb-test (bytespec integer)
  207.   `(not (zerop (mask-field ,bytespec ,integer))))
  208.  
  209.  
  210. ;;; With the ratio and complex accessors, we pick off the "identity" case, and
  211. ;;; use a primitive to handle the cell access case.
  212. ;;;
  213. (def-source-transform numerator (num)
  214.   (once-only ((n-num `(the rational ,num)))
  215.     `(if (ratiop ,n-num)
  216.      (%primitive numerator ,n-num)
  217.      ,n-num)))
  218. ;;;
  219. (def-source-transform denominator (num)
  220.   (once-only ((n-num `(the rational ,num)))
  221.     `(if (ratiop ,n-num)
  222.      (%primitive denominator ,n-num)
  223.      1)))
  224. ;;;
  225. (def-source-transform realpart (num)
  226.   (once-only ((n-num num))
  227.     `(if (complexp ,n-num)
  228.      (%primitive realpart ,n-num)
  229.      ,n-num)))
  230. ;;;
  231. (def-source-transform imagpart (num)
  232.   (once-only ((n-num num))
  233.     `(cond ((complexp ,n-num)
  234.         (%primitive imagpart ,n-num))
  235.        ((floatp ,n-num)
  236.         (float 0 ,n-num))
  237.        (t
  238.         0))))
  239.  
  240.  
  241. ;;;; Numeric Derive-Type methods:
  242.  
  243. ;;; Derive-Integer-Type  --  Internal
  244. ;;;
  245. ;;;    Utility for defining derive-type methods of integer operations.  If the
  246. ;;; types of both X and Y are integer types, then we compute a new integer type
  247. ;;; with bounds determined Fun when applied to X and Y.  Otherwise, we use
  248. ;;; Numeric-Contagion.
  249. ;;;
  250. (defun derive-integer-type (x y fun)
  251.   (declare (type continuation x y) (type function fun))
  252.   (let ((x (continuation-type x))
  253.     (y (continuation-type y)))
  254.     (if (and (numeric-type-p x) (numeric-type-p y)
  255.          (eq (numeric-type-class x) 'integer)
  256.          (eq (numeric-type-class y) 'integer)
  257.          (eq (numeric-type-complexp x) :real)
  258.          (eq (numeric-type-complexp y) :real))
  259.     (multiple-value-bind (low high)
  260.                  (funcall fun x y)
  261.       (make-numeric-type :class 'integer  :complexp :real
  262.                  :low low  :high high))
  263.     (numeric-contagion x y))))
  264.  
  265.  
  266. (defoptimizer (+ derive-type) ((x y))
  267.   (derive-integer-type
  268.    x y
  269.    #'(lambda (x y)
  270.        (flet ((frob (x y)
  271.         (if (and x y)
  272.             (+ x y)
  273.             nil)))
  274.      (values (frob (numeric-type-low x) (numeric-type-low y))
  275.          (frob (numeric-type-high x) (numeric-type-high y)))))))
  276.  
  277. (defoptimizer (- derive-type) ((x y))
  278.   (derive-integer-type
  279.    x y
  280.    #'(lambda (x y)
  281.        (flet ((frob (x y)
  282.         (if (and x y)
  283.             (- x y)
  284.             nil)))
  285.      (values (frob (numeric-type-low x) (numeric-type-high y))
  286.          (frob (numeric-type-high x) (numeric-type-low y)))))))
  287.  
  288. (defoptimizer (* derive-type) ((x y))
  289.   (derive-integer-type
  290.    x y
  291.    #'(lambda (x y)
  292.        (let ((x-low (numeric-type-low x))
  293.          (x-high (numeric-type-high x))
  294.          (y-low (numeric-type-low y))
  295.          (y-high (numeric-type-high y)))
  296.      (cond ((not (and x-low y-low))
  297.         (values nil nil))
  298.            ((or (minusp x-low) (minusp y-low))
  299.         (if (and x-high y-high)
  300.             (let ((max (* (max (abs x-low) (abs x-high))
  301.                   (max (abs y-low) (abs y-high)))))
  302.               (values (- max) max))
  303.             (values nil nil)))
  304.            (t
  305.         (values (* x-low y-low)
  306.             (if (and x-high y-high)
  307.                 (* x-high y-high)
  308.                 nil))))))))
  309.  
  310. (defoptimizer (/ derive-type) ((x y))
  311.   (numeric-contagion (continuation-type x) (continuation-type y)))
  312.  
  313.  
  314. (defoptimizer (ash derive-type) ((n shift))
  315.   (or (let ((n-type (continuation-type n)))
  316.     (when (numeric-type-p n-type)
  317.       (let ((n-low (numeric-type-low n-type))
  318.         (n-high (numeric-type-high n-type)))
  319.         (if (constant-continuation-p shift)
  320.         (let ((shift (continuation-value shift)))
  321.           (make-numeric-type :class 'integer  :complexp :real
  322.                      :low (when n-low
  323.                         #+new-compiler
  324.                         (ash n-low shift)
  325.                         ;; ### fuckin' bignum bug.
  326.                         #-new-compiler
  327.                         (* n-low (ash 1 shift)))
  328.                      :high (when n-high (ash n-high shift))))
  329.         (let ((s-type (continuation-type shift)))
  330.           (when (numeric-type-p s-type)
  331.             (let ((s-low (numeric-type-low s-type))
  332.               (s-high (numeric-type-high s-type)))
  333.               (if (and s-low s-high (<= s-low 32) (<= s-high 32))
  334.               (make-numeric-type :class 'integer  :complexp :real
  335.                          :low (when n-low
  336.                             (min (ash n-low s-high)
  337.                              (ash n-low s-low)))
  338.                          :high (when n-high
  339.                              (max (ash n-high s-high)
  340.                               (ash n-high s-low))))
  341.               (make-numeric-type :class 'integer
  342.                          :complexp :real)))))))))
  343.       *universal-type*))
  344.  
  345.  
  346. (macrolet ((frob (fun)
  347.          `#'(lambda (type type2)
  348.           (declare (ignore type2))
  349.           (let ((lo (numeric-type-low type))
  350.             (hi (numeric-type-high type)))
  351.             (values (if hi (,fun hi) nil) (if lo (,fun lo) nil))))))
  352.  
  353.   (defoptimizer (%negate derive-type) ((num))
  354.     (derive-integer-type num num (frob -)))
  355.  
  356.   (defoptimizer (lognot derive-type) ((int))
  357.     (derive-integer-type int int (frob lognot))))
  358.  
  359.  
  360. (defoptimizer (abs derive-type) ((num))
  361.   (let ((type (continuation-type num)))
  362.     (if (and (numeric-type-p type)
  363.          (eq (numeric-type-class type) 'integer)
  364.          (eq (numeric-type-complexp type) :real))
  365.     (let ((lo (numeric-type-low type))
  366.           (hi (numeric-type-high type)))
  367.       (make-numeric-type :class 'integer :complexp :real
  368.                  :low (cond ((and hi (minusp hi))
  369.                      (abs hi))
  370.                     (lo
  371.                      (max 0 lo))
  372.                     (t
  373.                      0))
  374.                  :high (if (and hi lo)
  375.                        (max (abs hi) (abs lo))
  376.                        nil)))
  377.     (numeric-contagion type type))))
  378.  
  379.  
  380. (defoptimizer (truncate derive-type) ((number divisor))
  381.   (let ((number-type (continuation-type number))
  382.     (divisor-type (continuation-type divisor))
  383.     (integer-type (specifier-type 'integer)))
  384.     (if (and (numeric-type-p number-type)
  385.          (csubtypep number-type integer-type)
  386.          (numeric-type-p divisor-type)
  387.          (csubtypep divisor-type integer-type))
  388.     (let ((number-low (numeric-type-low number-type))
  389.           (number-high (numeric-type-high number-type))
  390.           (divisor-low (numeric-type-low divisor-type))
  391.           (divisor-high (numeric-type-high divisor-type)))
  392.       (values-specifier-type
  393.        `(values ,(integer-truncate-derive-type number-low number-high
  394.                            divisor-low divisor-high)
  395.             ,(integer-rem-derive-type number-low number-high
  396.                           divisor-low divisor-high))))
  397.     *universal-type*)))
  398.  
  399. ;;; NUMERIC-RANGE-INFO  --  internal.
  400. ;;;
  401. ;;; Derive useful information about the range.  Returns three values:
  402. ;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
  403. ;;; - The abs of the minimal value (i.e. closest to 0) in the range.
  404. ;;; - The abs of the maximal value if there is one, or nil if it is unbounded.
  405. ;;; 
  406. (defun numeric-range-info (low high)
  407.   (cond ((and low (not (minusp low)))
  408.      (values '+ low high))
  409.     ((and high (not (plusp high)))
  410.      (values '- (- high) (if low (- low) nil)))
  411.     (t
  412.      (values nil 0 (and low high (max (- low) high))))))
  413.  
  414. ;;; INTEGER-TRUNCATE-DERIVE-TYPE -- internal
  415. ;;; 
  416. (defun integer-truncate-derive-type
  417.        (number-low number-high divisor-low divisor-high)
  418.   ;; The result cannot be larger in magnitude than the number, but the sign
  419.   ;; might change.  If we can determine the sign of either the number or
  420.   ;; the divisor, we can eliminate some of the cases.
  421.   (multiple-value-bind
  422.       (number-sign number-min number-max)
  423.       (numeric-range-info number-low number-high)
  424.     (multiple-value-bind
  425.     (divisor-sign divisor-min divisor-max)
  426.     (numeric-range-info divisor-low divisor-high)
  427.       (when (and divisor-max (zerop divisor-max))
  428.     ;; We've got a problem: guarenteed division by zero.
  429.     (return-from integer-truncate-derive-type t))
  430.       (when (zerop divisor-min)
  431.     ;; We'll assume that they arn't going to divide by zero.
  432.     (incf divisor-min))
  433.       (cond ((and number-sign divisor-sign)
  434.          ;; We know the sign of both.
  435.          (if (eq number-sign divisor-sign)
  436.          ;; Same sign, so the result will be positive.
  437.          `(integer ,(if divisor-max
  438.                 (truncate number-min divisor-max)
  439.                 0)
  440.                ,(if number-max
  441.                 (truncate number-max divisor-min)
  442.                 '*))
  443.          ;; Different signs, the result will be negative.
  444.          `(integer ,(if number-max
  445.                 (- (truncate number-max divisor-min))
  446.                 '*)
  447.                ,(if divisor-max
  448.                 (- (truncate number-min divisor-max))
  449.                 0))))
  450.         ((eq divisor-sign '+)
  451.          ;; The divisor is positive.  Therefore, the number will just
  452.          ;; become closer to zero.
  453.          `(integer ,(if number-low
  454.                 (truncate number-low divisor-min)
  455.                 '*)
  456.                ,(if number-high
  457.                 (truncate number-high divisor-min)
  458.                 '*)))
  459.         ((eq divisor-sign '-)
  460.          ;; The divisor is negative.  Therefore, the absolute value of
  461.          ;; the number will become closer to zero, but the sign will also
  462.          ;; change.
  463.          `(integer ,(if number-high
  464.                 (- (truncate number-high divisor-min))
  465.                 '*)
  466.                ,(if number-low
  467.                 (- (truncate number-low divisor-min))
  468.                 '*)))
  469.         ;; The divisor could be either positive or negative.
  470.         (number-max
  471.          ;; The number we are dividing has a bound.  Divide that by the
  472.          ;; smallest posible divisor.
  473.          (let ((bound (truncate number-max divisor-min)))
  474.            `(integer ,(- bound) ,bound)))
  475.         (t
  476.          ;; The number we are dividing is unbounded, so we can't tell
  477.          ;; anything about the result.
  478.          'integer)))))
  479.       
  480. (defun integer-rem-derive-type
  481.        (number-low number-high divisor-low divisor-high)
  482.   (if (and divisor-low divisor-high)
  483.       ;; We know the range of the divisor, and the remainder must be smaller
  484.       ;; than the divisor.  We can tell the sign of the remainer if we know
  485.       ;; the sign of the number.
  486.       (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
  487.     `(integer ,(if (or (null number-low)
  488.                (minusp number-low))
  489.                (- divisor-max)
  490.                0)
  491.           ,(if (or (null number-high)
  492.                (plusp number-high))
  493.                divisor-max
  494.                0)))
  495.       ;; The divisor is potentially either very positive or very negative.
  496.       ;; Therefore, the remainer is unbounded, but we might be able to tell
  497.       ;; something about the sign from the number.
  498.       `(integer ,(if (and number-low (not (minusp number-low)))
  499.              ;; The number we are dividing is positive.  Therefore,
  500.              ;; the remainder must be positive.
  501.              0
  502.              '*)
  503.         ,(if (and number-high (not (plusp number-high)))
  504.              ;; The number we are dividing is negative.  Therefore,
  505.              ;; the remainder must be negative.
  506.              0
  507.              '*))))
  508.  
  509. (defoptimizer (random derive-type) ((bound &optional state))
  510.   (let ((type (continuation-type bound)))
  511.     (when (numeric-type-p type)
  512.       (let ((class (numeric-type-class type))
  513.         (high (numeric-type-high type))
  514.         (format (numeric-type-format type)))
  515.     (make-numeric-type
  516.      :class class
  517.      :format format
  518.      :low (coerce 0 (or format class 'real))
  519.      :high (cond ((not high) nil)
  520.              ((eq class 'integer) (max (1- high) 0))
  521.              ((or (consp high) (zerop high)) high)
  522.              (t `(,high))))))))
  523.  
  524.  
  525. ;;;; Logical derive-type methods:
  526.  
  527.  
  528. ;;; Integer-Type-Length -- Internal
  529. ;;;
  530. ;;; Return the maximum number of bits an integer of the supplied type can take
  531. ;;; up, or NIL if it is unbounded.  The second (third) value is T if the
  532. ;;; integer can be positive (negative) and NIL if not.  Zero counts as
  533. ;;; positive.
  534. ;;;
  535. (defun integer-type-length (type)
  536.   (if (numeric-type-p type)
  537.       (let ((min (numeric-type-low type))
  538.         (max (numeric-type-high type)))
  539.     (values (and min max (max (integer-length min) (integer-length max)))
  540.         (or (null max) (not (minusp max)))
  541.         (or (null min) (minusp min))))
  542.       (values nil t t)))
  543.  
  544. (defoptimizer (logand derive-type) ((x y))
  545.   (multiple-value-bind
  546.       (x-len x-pos x-neg)
  547.       (integer-type-length (continuation-type x))
  548.     (declare (ignore x-pos))
  549.     (multiple-value-bind
  550.     (y-len y-pos y-neg)
  551.     (integer-type-length (continuation-type y))
  552.       (declare (ignore y-pos))
  553.       (if (not x-neg)
  554.       ;; X must be positive.
  555.       (if (not y-neg)
  556.           ;; The must both be positive.
  557.           (cond ((or (null x-len) (null y-len))
  558.              (specifier-type 'unsigned-byte))
  559.             ((or (zerop x-len) (zerop y-len))
  560.              (specifier-type '(integer 0 0)))
  561.             (t
  562.              (specifier-type `(unsigned-byte ,(min x-len y-len)))))
  563.           ;; X is positive, but Y might be negative.
  564.           (cond ((null x-len)
  565.              (specifier-type 'unsigned-byte))
  566.             ((zerop x-len)
  567.              (specifier-type '(integer 0 0)))
  568.             (t
  569.              (specifier-type `(unsigned-byte ,x-len)))))
  570.       ;; X might be negative.
  571.       (if (not y-neg)
  572.           ;; Y must be positive.
  573.           (cond ((null y-len)
  574.              (specifier-type 'unsigned-byte))
  575.             ((zerop y-len)
  576.              (specifier-type '(integer 0 0)))
  577.             (t
  578.              (specifier-type
  579.               `(unsigned-byte ,y-len))))
  580.           ;; Either might be negative.
  581.           (if (and x-len y-len)
  582.           ;; The result is bounded.
  583.           (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
  584.           ;; We can't tell squat about the result.
  585.           (specifier-type 'integer)))))))
  586.  
  587. (defoptimizer (logior derive-type) ((x y))
  588.   (multiple-value-bind
  589.       (x-len x-pos x-neg)
  590.       (integer-type-length (continuation-type x))
  591.     (multiple-value-bind
  592.     (y-len y-pos y-neg)
  593.     (integer-type-length (continuation-type y))
  594.       (cond
  595.        ((and (not x-neg) (not y-neg))
  596.     ;; Both are positive.
  597.     (specifier-type `(unsigned-byte ,(if (and x-len y-len)
  598.                          (max x-len y-len)
  599.                          '*))))
  600.        ((not x-pos)
  601.     ;; X must be negative.
  602.     (if (not y-pos)
  603.         ;; Both are negative.  The result is going to be negative and be
  604.         ;; the same length or shorter than the smaller.
  605.         (if (and x-len y-len)
  606.         ;; It's bounded.
  607.         (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
  608.         ;; It's unbounded.
  609.         (specifier-type '(integer * -1)))
  610.         ;; X is negative, but we don't know about Y.  The result will be
  611.         ;; negative, but no more negative than X.
  612.         (specifier-type
  613.          `(integer ,(or (numeric-type-low (continuation-type x)) '*)
  614.                -1))))
  615.        (t
  616.     ;; X might be either positive or negative.
  617.     (if (not y-pos)
  618.         ;; But Y is negative.  The result will be negative.
  619.         (specifier-type
  620.          `(integer ,(or (numeric-type-low (continuation-type y)) '*)
  621.                -1))
  622.         ;; We don't know squat about either.  It won't get any bigger.
  623.         (if (and x-len y-len)
  624.         ;; Bounded.
  625.         (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
  626.         ;; Unbounded.
  627.         (specifier-type 'integer))))))))
  628.  
  629. (defoptimizer (logxor derive-type) ((x y))
  630.   (multiple-value-bind
  631.       (x-len x-pos x-neg)
  632.       (integer-type-length (continuation-type x))
  633.     (multiple-value-bind
  634.     (y-len y-pos y-neg)
  635.     (integer-type-length (continuation-type y))
  636.       (cond
  637.        ((or (and (not x-neg) (not y-neg))
  638.         (and (not x-pos) (not y-pos)))
  639.     ;; Either both are negative or both are positive.  The result will be
  640.     ;; positive, and as long as the longer.
  641.     (specifier-type `(unsigned-byte ,(if (and x-len y-len)
  642.                          (max x-len y-len)
  643.                          '*))))
  644.        ((or (and (not x-pos) (not y-neg))
  645.         (and (not y-neg) (not y-pos)))
  646.     ;; Either X is negative and Y is positive of vice-verca.  The result
  647.     ;; will be negative.
  648.     (specifier-type `(integer ,(if (and x-len y-len)
  649.                        (ash -1 (max x-len y-len))
  650.                        '*)
  651.                   -1)))
  652.        ;; We can't tell what the sign of the result is going to be.  All we
  653.        ;; know is that we don't create new bits.
  654.        ((and x-len y-len)
  655.     (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
  656.        (t
  657.     (specifier-type 'integer))))))
  658.  
  659.  
  660.  
  661. ;;;; Miscellaneous derive-type methods:
  662.  
  663.  
  664. (defoptimizer (code-char derive-type) ((code))
  665.   (specifier-type 'base-char))
  666.  
  667.  
  668. (defoptimizer (values derive-type) ((&rest values))
  669.   (values-specifier-type
  670.    `(values ,@(mapcar #'(lambda (x)
  671.               (type-specifier (continuation-type x)))
  672.               values))))
  673.  
  674.  
  675.  
  676. ;;;; Byte operations:
  677. ;;;
  678. ;;;    We try to turn byte operations into simple logical operations.  First,
  679. ;;; we convert byte specifiers into separate size and position arguments passed
  680. ;;; to internal %FOO functions.  We then attempt to transform the %FOO
  681. ;;; functions into boolean operations when the size and position are constant
  682. ;;; and the operands are fixnums.
  683.  
  684.  
  685. ;;; With-Byte-Specifier  --  Internal
  686. ;;;
  687. ;;;    Evaluate body with Size-Var and Pos-Var bound to expressions that
  688. ;;; evaluate to the Size and Position of the byte-specifier form Spec.  We may
  689. ;;; wrap a let around the result of the body to bind some variables.
  690. ;;;
  691. ;;;    If the spec is a Byte form, then bind the vars to the subforms.
  692. ;;; otherwise, evaluate Spec and use the Byte-Size and Byte-Position.  The goal
  693. ;;; of this transformation is to avoid consing up byte specifiers and then
  694. ;;; immediately throwing them away.
  695. ;;;
  696. (defmacro with-byte-specifier ((size-var pos-var spec) &body body)
  697.   (once-only ((spec `(macroexpand ,spec))
  698.           (temp '(gensym)))
  699.     `(if (and (consp ,spec)
  700.           (eq (car ,spec) 'byte)
  701.           (= (length ,spec) 3))
  702.      (let ((,size-var (second ,spec))
  703.            (,pos-var (third ,spec)))
  704.        ,@body)
  705.      (let ((,size-var `(byte-size ,,temp))
  706.            (,pos-var `(byte-position ,,temp)))
  707.        `(let ((,,temp ,,spec))
  708.           ,,@body)))))
  709.  
  710. (def-source-transform ldb (spec int)
  711.   (with-byte-specifier (size pos spec)
  712.     `(%ldb ,size ,pos ,int)))
  713.  
  714. (def-source-transform dpb (newbyte spec int)
  715.   (with-byte-specifier (size pos spec)
  716.     `(%dpb ,newbyte ,size ,pos ,int)))
  717.  
  718. (def-source-transform mask-field (spec int)
  719.   (with-byte-specifier (size pos spec)
  720.     `(%mask-field ,size ,pos ,int)))
  721.  
  722. (def-source-transform deposit-field (newbyte spec int)
  723.   (with-byte-specifier (size pos spec)
  724.     `(%deposit-field ,newbyte ,size ,pos ,int)))
  725.  
  726.  
  727. (defoptimizer (%ldb derive-type) ((size posn num))
  728.   (let ((size (continuation-type size)))
  729.     (if (and (numeric-type-p size)
  730.          (csubtypep size (specifier-type 'integer)))
  731.     (let ((size-high (numeric-type-high size)))
  732.       (if (and size-high (<= size-high vm:word-bits))
  733.           (specifier-type `(unsigned-byte ,size-high))
  734.           (specifier-type 'unsigned-byte)))
  735.     *universal-type*)))
  736.  
  737. (defoptimizer (%mask-field derive-type) ((size posn num))
  738.   (let ((size (continuation-type size))
  739.     (posn (continuation-type posn)))
  740.     (if (and (numeric-type-p size)
  741.          (csubtypep size (specifier-type 'integer))
  742.          (numeric-type-p posn)
  743.          (csubtypep posn (specifier-type 'integer)))
  744.     (let ((size-high (numeric-type-high size))
  745.           (posn-high (numeric-type-high posn)))
  746.       (if (and size-high posn-high
  747.            (<= (+ size-high posn-high) vm:word-bits))
  748.           (specifier-type `(unsigned-byte ,(+ size-high posn-high)))
  749.           (specifier-type 'unsigned-byte)))
  750.     *universal-type*)))
  751.  
  752. (defoptimizer (%dpb derive-type) ((newbyte size posn int))
  753.   (let ((size (continuation-type size))
  754.     (posn (continuation-type posn))
  755.     (int (continuation-type int)))
  756.     (if (and (numeric-type-p size)
  757.          (csubtypep size (specifier-type 'integer))
  758.          (numeric-type-p posn)
  759.          (csubtypep posn (specifier-type 'integer))
  760.          (numeric-type-p int)
  761.          (csubtypep int (specifier-type 'integer)))
  762.     (let ((size-high (numeric-type-high size))
  763.           (posn-high (numeric-type-high posn))
  764.           (high (numeric-type-high int))
  765.           (low (numeric-type-low int)))
  766.       (if (and size-high posn-high high low
  767.            (<= (+ size-high posn-high) vm:word-bits))
  768.           (specifier-type
  769.            (list (if (minusp low) 'signed-byte 'unsigned-byte)
  770.              (max (integer-length high)
  771.               (integer-length low)
  772.               (+ size-high posn-high))))
  773.           *universal-type*))
  774.     *universal-type*)))
  775.  
  776. (defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
  777.   (let ((size (continuation-type size))
  778.     (posn (continuation-type posn))
  779.     (int (continuation-type int)))
  780.     (if (and (numeric-type-p size)
  781.          (csubtypep size (specifier-type 'integer))
  782.          (numeric-type-p posn)
  783.          (csubtypep posn (specifier-type 'integer))
  784.          (numeric-type-p int)
  785.          (csubtypep int (specifier-type 'integer)))
  786.     (let ((size-high (numeric-type-high size))
  787.           (posn-high (numeric-type-high posn))
  788.           (high (numeric-type-high int))
  789.           (low (numeric-type-low int)))
  790.       (if (and size-high posn-high high low
  791.            (<= (+ size-high posn-high) vm:word-bits))
  792.           (specifier-type
  793.            (list (if (minusp low) 'signed-byte 'unsigned-byte)
  794.              (max (integer-length high)
  795.               (integer-length low)
  796.               (+ size-high posn-high))))
  797.           *universal-type*))
  798.     *universal-type*)))
  799.  
  800.  
  801.  
  802. (deftransform %ldb ((size posn int)
  803.             (fixnum fixnum integer)
  804.             (unsigned-byte #.vm:word-bits))
  805.   "convert to inline logical ops"
  806.   `(logand (ash int (- posn))
  807.        (ash ,(1- (ash 1 vm:word-bits))
  808.         (- size ,vm:word-bits))))
  809.  
  810. (deftransform %mask-field ((size posn int)
  811.                (fixnum fixnum integer)
  812.                (unsigned-byte #.vm:word-bits))
  813.   "convert to inline logical ops"
  814.   `(logand int
  815.        (ash (ash ,(1- (ash 1 vm:word-bits))
  816.              (- size ,vm:word-bits))
  817.         posn)))
  818.  
  819. ;;; Note: for %dpb and %deposit-field, we can't use (or (signed-byte n)
  820. ;;; (unsigned-byte n)) as the result type, as that would allow result types
  821. ;;; that cover the range -2^(n-1) .. 1-2^n, instead of allowing result types
  822. ;;; of (unsigned-byte n) and result types of (signed-byte n).
  823.  
  824. (deftransform %dpb ((new size posn int)
  825.             *
  826.             (unsigned-byte #.vm:word-bits))
  827.   "convert to inline logical ops"
  828.   `(let ((mask (ldb (byte size 0) -1)))
  829.      (logior (ash (logand new mask) posn)
  830.          (logand int (lognot (ash mask posn))))))
  831.  
  832. (deftransform %dpb ((new size posn int)
  833.             *
  834.             (signed-byte #.vm:word-bits))
  835.   "convert to inline logical ops"
  836.   `(let ((mask (ldb (byte size 0) -1)))
  837.      (logior (ash (logand new mask) posn)
  838.          (logand int (lognot (ash mask posn))))))
  839.  
  840. (deftransform %deposit-field ((new size posn int)
  841.                   *
  842.                   (unsigned-byte #.vm:word-bits))
  843.   "convert to inline logical ops"
  844.   `(let ((mask (ash (ldb (byte size 0) -1) posn)))
  845.      (logior (logand new mask)
  846.          (logand int (lognot mask)))))
  847.  
  848. (deftransform %deposit-field ((new size posn int)
  849.                   *
  850.                   (signed-byte #.vm:word-bits))
  851.   "convert to inline logical ops"
  852.   `(let ((mask (ash (ldb (byte size 0) -1) posn)))
  853.      (logior (logand new mask)
  854.          (logand int (lognot mask)))))
  855.  
  856.  
  857. ;;;; Funny function stubs:
  858. ;;;
  859. ;;;    These functions are the result of compiler transformations.  We never
  860. ;;; actually compile a call to these functions, but we need to have a
  861. ;;; definition to allow constant folding.
  862. ;;;
  863.  
  864. #-new-compiler
  865. (progn
  866.  
  867. (defun %negate (x) (%primitive negate x))
  868. (defun %ldb (s p i) (%primitive ldb s p i))
  869. (defun %dpb (n s p i) (%primitive dpb n s p i))
  870. (defun %mask-field (s p i) (%primitive mask-field s p i))
  871. (defun %deposit-field (n s p i) (%primitive deposit-field n s p i))
  872.  
  873. ); #-new-compiler progn
  874.  
  875.  
  876. ;;; Miscellanous numeric transforms:
  877.  
  878.  
  879. ;;; COMMUTATIVE-ARG-SWAP  --  Internal
  880. ;;;
  881. ;;;    If a constant appears as the first arg, swap the args.
  882. ;;;
  883. (deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
  884.   (if (and (constant-continuation-p x)
  885.        (not (constant-continuation-p y)))
  886.       `(,(continuation-function-name (basic-combination-fun node))
  887.     y
  888.     ,(continuation-value x))
  889.       (give-up)))
  890.  
  891. (dolist (x '(= char= + * logior logand logxor))
  892.   (%deftransform x '(function * *) #'commutative-arg-swap
  893.          "place constant arg last."))
  894.  
  895. ;;; Handle the case of a constant boole-code.
  896. ;;;
  897. (deftransform boole ((op x y))
  898.   "convert to inline logical ops"
  899.   (unless (constant-continuation-p op)
  900.     (give-up "BOOLE code is not a constant."))
  901.   (let ((control (continuation-value op)))
  902.     (case control
  903.       (#.boole-clr 0)
  904.       (#.boole-set -1)
  905.       (#.boole-1 'x)
  906.       (#.boole-2 'y)
  907.       (#.boole-c1 '(lognot x))
  908.       (#.boole-c2 '(lognot y))
  909.       (#.boole-and '(logand x y))
  910.       (#.boole-ior '(logior x y))
  911.       (#.boole-xor '(logxor x y))
  912.       (#.boole-eqv '(logeqv x y))
  913.       (#.boole-nand '(lognand x y))
  914.       (#.boole-nor '(lognor x y))
  915.       (#.boole-andc1 '(logandc1 x y))
  916.       (#.boole-andc2 '(logandc2 x y))
  917.       (#.boole-orc1 '(logorc1 x y))
  918.       (#.boole-orc2 '(logorc2 x y))
  919.       (t
  920.        (abort-transform "~S illegal control arg to BOOLE." control)))))
  921.  
  922.  
  923. ;;;; Convert multiply/divide to shifts.
  924.  
  925. ;;; If arg is a constant power of two, turn * into a shift.
  926. ;;;
  927. (deftransform * ((x y) (integer integer))
  928.   "convert x*2^k to shift"
  929.   (unless (constant-continuation-p y) (give-up))
  930.   (let* ((y (continuation-value y))
  931.      (y-abs (abs y))
  932.      (len (1- (integer-length y-abs))))
  933.     (unless (= y-abs (ash 1 len)) (give-up))
  934.     (if (minusp y)
  935.     `(- (ash x ,len))
  936.     `(ash x ,len))))
  937.  
  938. ;;; If both arguments and the result are (unsigned-byte 32), try to come up
  939. ;;; with a ``better'' multiplication using multiplier recoding.  There are two
  940. ;;; different ways the multiplier can be recoded.  The more obvious is to shift
  941. ;;; X by the correct amount for each bit set in Y and to sum the results.  But
  942. ;;; if there is a string of bits that are all set, you can add X shifted by
  943. ;;; one more then the bit position of the first set bit and subtract X shifted
  944. ;;; by the bit position of the last set bit.  We can't use this second method
  945. ;;; when the high order bit is bit 31 because shifting by 32 doesn't work
  946. ;;; too well.
  947. ;;; 
  948. (deftransform * ((x y)
  949.          ((unsigned-byte 32) (unsigned-byte 32))
  950.          (unsigned-byte 32))
  951.   "recode as shift and add"
  952.   (unless (constant-continuation-p y)
  953.     (give-up))
  954.   (let ((y (continuation-value y))
  955.     (result nil)
  956.     (first-one nil))
  957.     (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x))
  958.          (add (next-factor)
  959.            (setf result
  960.              (tub32
  961.               (if result
  962.               `(+ ,result ,(tub32 next-factor))
  963.               next-factor)))))
  964.       (declare (inline add))
  965.       (dotimes (bitpos 32)
  966.     (if first-one
  967.         (when (not (logbitp bitpos y))
  968.           (add (if (= (1+ first-one) bitpos)
  969.                ;; There is only a single bit in the string.
  970.                `(ash x ,first-one)
  971.                ;; There are at least two.
  972.                `(- ,(tub32 `(ash x ,bitpos))
  973.                ,(tub32 `(ash x ,first-one)))))
  974.           (setf first-one nil))
  975.         (when (logbitp bitpos y)
  976.           (setf first-one bitpos))))
  977.       (when first-one
  978.     (cond ((= first-one 31))
  979.           ((= first-one 30)
  980.            (add '(ash x 30)))
  981.           (t
  982.            (add `(- ,(tub32 '(ash x 31)) ,(tub32 `(ash x ,first-one))))))
  983.     (add '(ash x 31))))
  984.     (or result 0)))
  985.  
  986. ;;; If arg is a constant power of two, turn floor into a shift and mask.
  987. ;;; If ceiling, add in (1- (abs y)) and then do floor.
  988. ;;;
  989. (flet ((frob (y ceil-p)
  990.      (unless (constant-continuation-p y) (give-up))
  991.      (let* ((y (continuation-value y))
  992.         (y-abs (abs y))
  993.         (len (1- (integer-length y-abs))))
  994.        (unless (= y-abs (ash 1 len)) (give-up))
  995.        (let ((shift (- len))
  996.          (mask (1- y-abs)))
  997.          `(let ,(when ceil-p `((x (+ x ,(1- y-abs)))))
  998.         ,(if (minusp y)
  999.              `(values (ash (- x) ,shift)
  1000.                   (- (logand (- x) ,mask)))
  1001.              `(values (ash x ,shift)
  1002.                   (logand x ,mask))))))))
  1003.   (deftransform floor ((x y) (integer integer))
  1004.     "convert division by 2^k to shift"
  1005.     (frob y nil))
  1006.   (deftransform ceiling ((x y) (integer integer))
  1007.     "convert division by 2^k to shift"
  1008.     (frob y t)))
  1009.  
  1010.  
  1011. ;;; Do the same for mod.
  1012. ;;;
  1013. (deftransform mod ((x y) (integer integer))
  1014.   "convert remainder mod 2^k to LOGAND"
  1015.   (unless (constant-continuation-p y) (give-up))
  1016.   (let* ((y (continuation-value y))
  1017.      (y-abs (abs y))
  1018.      (len (1- (integer-length y-abs))))
  1019.     (unless (= y-abs (ash 1 len)) (give-up))
  1020.     (let ((mask (1- y-abs)))
  1021.       (if (minusp y)
  1022.       `(- (logand (- x) ,mask))
  1023.       `(logand x ,mask)))))
  1024.  
  1025.  
  1026. ;;; If arg is a constant power of two, turn truncate into a shift and mask.
  1027. ;;;
  1028. (deftransform truncate ((x y) (integer integer))
  1029.   "convert division by 2^k to shift"
  1030.   (unless (constant-continuation-p y) (give-up))
  1031.   (let* ((y (continuation-value y))
  1032.      (y-abs (abs y))
  1033.      (len (1- (integer-length y-abs))))
  1034.     (unless (= y-abs (ash 1 len)) (give-up))
  1035.     (let* ((shift (- len))
  1036.        (mask (1- y-abs)))
  1037.       `(if (minusp x)
  1038.        (values ,(if (minusp y)
  1039.             `(ash (- x) ,shift)
  1040.             `(- (ash (- x) ,shift)))
  1041.            (- (logand (- x) ,mask)))
  1042.        (values ,(if (minusp y)
  1043.             `(- (ash (- x) ,shift))
  1044.             `(ash x ,shift))
  1045.            (logand x ,mask))))))
  1046.  
  1047. ;;; And the same for rem.
  1048. ;;;
  1049. (deftransform rem ((x y) (integer integer))
  1050.   "convert remainder mod 2^k to LOGAND"
  1051.   (unless (constant-continuation-p y) (give-up))
  1052.   (let* ((y (continuation-value y))
  1053.      (y-abs (abs y))
  1054.      (len (1- (integer-length y-abs))))
  1055.     (unless (= y-abs (ash 1 len)) (give-up))
  1056.     (let ((mask (1- y-abs)))
  1057.       `(if (minusp x)
  1058.        (- (logand (- x) ,mask))
  1059.        (logand x ,mask)))))
  1060.  
  1061.  
  1062. ;;;; Arithmetic and logical identity operation elimination:
  1063. ;;;
  1064. ;;; Flush calls to random arith functions that convert to the identity
  1065. ;;; function or a constant.
  1066.  
  1067.  
  1068. (dolist (stuff '((ash 0 x)
  1069.          (logand -1 x)
  1070.          (logand 0 0)
  1071.          (logior 0 x)
  1072.          (logior -1 -1)
  1073.          (logxor -1 (lognot x))
  1074.          (logxor 0 x)))
  1075.   (destructuring-bind (name identity result) stuff
  1076.     (deftransform name ((x y) `(* (constant-argument (member ,identity))) '*
  1077.             :eval-name t)
  1078.       "fold identity operations"
  1079.       result)))
  1080.  
  1081.  
  1082. ;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
  1083. ;;; (* 0 -4.0) is -0.0.
  1084. ;;;
  1085. (deftransform - ((x y) ((constant-argument (member 0)) rational))
  1086.   "convert (- 0 x) to negate"
  1087.   '(%negate y))
  1088. ;;;
  1089. (deftransform * ((x y) (rational (constant-argument (member 0))))
  1090.   "convert (* x 0) to 0."
  1091.   0)
  1092.  
  1093.  
  1094. ;;; NOT-MORE-CONTAGIOUS  --  Interface
  1095. ;;;
  1096. ;;;    Return T if in an arithmetic op including continuations X and Y, the
  1097. ;;; result type is not affected by the type of X.  That is, Y is at least as
  1098. ;;; contagious as X.
  1099. ;;;
  1100. (defun not-more-contagious (x y)
  1101.   (declare (type continuation x y))
  1102.   (let ((x (continuation-type x))
  1103.     (y (continuation-type y)))
  1104.     (values (type= (numeric-contagion x y)
  1105.            (numeric-contagion y y)))))
  1106.  
  1107.  
  1108. ;;; Fold (OP x 0).
  1109. ;;;
  1110. ;;;    If y is not constant, not zerop, or is contagious, then give up.
  1111. ;;;
  1112. (dolist (stuff '((+ x)
  1113.          (- x)
  1114.          (expt 1)))
  1115.   (destructuring-bind (name result) stuff
  1116.     (deftransform name ((x y) '(t (constant-argument t)) '* :eval-name t)
  1117.       "fold zero arg"
  1118.       (let ((val (continuation-value y)))
  1119.     (unless (and (zerop val)
  1120.              (not (and (floatp val) (minusp (float-sign val))))
  1121.              (not-more-contagious y x))
  1122.       (give-up)))
  1123.       result)))
  1124.  
  1125. ;;; Fold (OP x +/-1)
  1126. ;;;
  1127. (dolist (stuff '((* x (%negate x))
  1128.          (/ x (%negate x))
  1129.          (expt x (/ 1 x))))
  1130.   (destructuring-bind (name result minus-result) stuff
  1131.     (deftransform name ((x y) '(t (constant-argument real)) '* :eval-name t)
  1132.       "fold identity operations"
  1133.       (let ((val (continuation-value y)))
  1134.     (unless (and (= (abs val) 1)
  1135.              (not-more-contagious y x))
  1136.       (give-up))
  1137.     (if (minusp val) minus-result result)))))
  1138.  
  1139.  
  1140. ;;;; Character operations:
  1141.  
  1142. (deftransform char-equal ((a b) (base-char base-char))
  1143.   "open code"
  1144.   '(let* ((ac (char-code a))
  1145.       (bc (char-code b))
  1146.       (sum (logxor ac bc)))
  1147.      (or (zerop sum)
  1148.      (when (eql sum #x20)
  1149.        (let ((sum (+ ac bc)))
  1150.          (and (> sum 161) (< sum 213)))))))
  1151.  
  1152. (deftransform char-upcase ((x) (base-char))
  1153.   "open code"
  1154.   '(let ((n-code (char-code x)))
  1155.      (if (and (> n-code #o140)    ; Octal 141 is #\a.
  1156.           (< n-code #o173))    ; Octal 172 is #\z.
  1157.      (code-char (logxor #x20 n-code))
  1158.      x)))
  1159.  
  1160. (deftransform char-downcase ((x) (base-char))
  1161.   "open code"
  1162.   '(let ((n-code (char-code x)))
  1163.      (if (and (> n-code 64)    ; 65 is #\A.
  1164.           (< n-code 91))    ; 90 is #\Z.
  1165.      (code-char (logxor #x20 n-code))
  1166.      x)))
  1167.  
  1168.  
  1169. ;;;; Equality predicate transforms:
  1170.  
  1171.  
  1172. ;;; SAME-LEAF-REF-P  --  Internal
  1173. ;;;
  1174. ;;;    Return true if X and Y are continuations whose only use is a reference
  1175. ;;; to the same leaf, and the value of the leaf cannot change.
  1176. ;;;
  1177. (defun same-leaf-ref-p (x y)
  1178.   (declare (type continuation x y))
  1179.   (let ((x-use (continuation-use x))
  1180.     (y-use (continuation-use y)))
  1181.     (and (ref-p x-use)
  1182.      (ref-p y-use)
  1183.      (eq (ref-leaf x-use) (ref-leaf y-use))
  1184.      (constant-reference-p x-use))))
  1185.  
  1186.  
  1187. ;;; SIMPLE-EQUALITY-TRANSFORM  --  Internal
  1188. ;;;
  1189. ;;;    If X and Y are the same leaf, then the result is true.  Otherwise, if
  1190. ;;; there is no intersection between the types of the arguments, then the
  1191. ;;; result is definitely false.
  1192. ;;;
  1193. (deftransform simple-equality-transform ((x y) * * :defun-only t)
  1194.   (cond ((same-leaf-ref-p x y)
  1195.      't)
  1196.     ((not (types-intersect (continuation-type x) (continuation-type y)))
  1197.      'nil)
  1198.     (t
  1199.      (give-up))))
  1200.  
  1201. (dolist (x '(eq char= equal))
  1202.   (%deftransform x '(function * *) #'simple-equality-transform))
  1203.  
  1204.  
  1205. ;;; EQL IR1 Transform  --  Internal
  1206. ;;;
  1207. ;;;    Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to convert
  1208. ;;; to a type-specific predicate or EQ:
  1209. ;;; -- If both args are characters, convert to CHAR=.  This is better than just
  1210. ;;;    converting to EQ, since CHAR= may have special compilation strategies
  1211. ;;;    for non-standard representations, etc.
  1212. ;;; -- If either arg is definitely not a number, then we can compare with EQ.
  1213. ;;; -- Otherwise, we try to put the arg we know more about second.  If X is
  1214. ;;;    constant then we put it second.  If X is a subtype of Y, we put it
  1215. ;;;    second.  These rules make it easier for the back end to match these
  1216. ;;;    interesting cases.
  1217. ;;; -- If Y is a fixnum, then we quietly pass because the back end can handle
  1218. ;;;    that case, otherwise give an efficency note.
  1219. ;;;
  1220. (deftransform eql ((x y))
  1221.   "convert to simpler equality predicate"
  1222.   (let ((x-type (continuation-type x))
  1223.     (y-type (continuation-type y))
  1224.     (char-type (specifier-type 'character))
  1225.     (number-type (specifier-type 'number)))
  1226.     (cond ((same-leaf-ref-p x y)
  1227.        't)
  1228.       ((not (types-intersect x-type y-type))
  1229.        'nil)
  1230.       ((and (csubtypep x-type char-type)
  1231.         (csubtypep y-type char-type))
  1232.        '(char= x y))
  1233.       ((or (not (types-intersect x-type number-type))
  1234.            (not (types-intersect y-type number-type)))
  1235.        '(eq x y))
  1236.       ((and (not (constant-continuation-p y))
  1237.         (or (constant-continuation-p x)
  1238.             (and (csubtypep x-type y-type)
  1239.              (not (csubtypep y-type x-type)))))
  1240.        '(eql y x))
  1241.       (t
  1242.        (give-up)))))
  1243.  
  1244.  
  1245. ;;; = IR1 Transform  --  Internal
  1246. ;;;
  1247. ;;;    Convert to EQL if both args are the "same" numeric type.  This allows
  1248. ;;; all of EQL's type-specific expertise to come into play.  "Same" means
  1249. ;;; either both rational or both floats of the same format.  Complexp must also
  1250. ;;; be specified and identical.
  1251. ;;; 
  1252. (deftransform = ((x y))
  1253.   "open code"
  1254.   (let ((x-type (continuation-type x))
  1255.     (y-type (continuation-type y)))
  1256.     (if (and (numeric-type-p x-type) (numeric-type-p y-type)
  1257.          (let ((x-class (numeric-type-class x-type))
  1258.            (y-class (numeric-type-class y-type))
  1259.            (x-format (numeric-type-format x-type)))
  1260.            (or (and (eq x-class 'float) (eq y-class 'float)
  1261.             x-format
  1262.             (eq x-format (numeric-type-format y-type)))
  1263.            (and (member x-class '(rational integer))
  1264.             (member y-class '(rational integer)))))
  1265.          (let ((x-complexp (numeric-type-complexp x-type)))
  1266.            (and x-complexp
  1267.             (eq x-complexp (numeric-type-complexp y-type)))))
  1268.     '(eql x y)
  1269.     (give-up "Operands might not be the same type."))))
  1270.  
  1271.  
  1272. ;;; Numeric-Type-Or-Lose  --  Interface
  1273. ;;;
  1274. ;;;    If Cont's type is a numeric type, then return the type, otherwise
  1275. ;;; GIVE-UP.
  1276. ;;;
  1277. (defun numeric-type-or-lose (cont)
  1278.   (declare (type continuation cont))
  1279.   (let ((res (continuation-type cont)))
  1280.     (unless (numeric-type-p res) (give-up))
  1281.     res))
  1282.  
  1283.  
  1284. ;;; IR1-TRANSFORM-<  --  Internal
  1285. ;;;
  1286. ;;;    See if we can statically determine (< X Y) using type information.  If
  1287. ;;; X's high bound is < Y's low, then X < Y.  Similarly, if X's low is >= to
  1288. ;;; Y's high, the X >= Y (so return NIL).  If not, at least make sure any
  1289. ;;; constant arg is second.
  1290. ;;;
  1291. (defun ir1-transform-< (x y first second inverse)
  1292.   (if (same-leaf-ref-p x y)
  1293.       'nil
  1294.       (let* ((x-type (numeric-type-or-lose x))
  1295.          (x-lo (numeric-type-low x-type))
  1296.          (x-hi (numeric-type-high x-type))
  1297.          (y-type (numeric-type-or-lose y))
  1298.          (y-lo (numeric-type-low y-type))
  1299.          (y-hi (numeric-type-high y-type)))
  1300.     (cond ((and x-hi y-lo (< x-hi y-lo))
  1301.            't)
  1302.           ((and y-hi x-lo (>= x-lo y-hi))
  1303.            'nil)
  1304.           ((and (constant-continuation-p first)
  1305.             (not (constant-continuation-p second)))
  1306.            `(,inverse y x))
  1307.           (t
  1308.            (give-up))))))
  1309.           
  1310.  
  1311. (deftransform < ((x y) (integer integer))
  1312.   (ir1-transform-< x y x y '>))
  1313.  
  1314. (deftransform > ((x y) (integer integer))
  1315.   (ir1-transform-< y x x y '<))
  1316.  
  1317.  
  1318. ;;;; Converting N-arg comparisons:
  1319. ;;;
  1320. ;;;    We convert calls to N-arg comparison functions such as < into two-arg
  1321. ;;; calls.  This transformation is enabled for all such comparisons in this
  1322. ;;; file.  If any of these predicates are not open-coded, then the
  1323. ;;; transformation should be removed at some point to avoid pessimization.
  1324.  
  1325. ;;; Multi-Compare  --  Internal
  1326. ;;;
  1327. ;;;    This function is used for source transformation of N-arg comparison
  1328. ;;; functions other than inequality.  We deal both with converting to two-arg
  1329. ;;; calls and inverting the sense of the test, if necessary.  If the call has
  1330. ;;; two args, then we pass or return a negated test as appropriate.  If it is a
  1331. ;;; degenerate one-arg call, then we transform to code that returns true.
  1332. ;;; Otherwise, we bind all the arguments and expand into a bunch of IFs.
  1333. ;;;
  1334. (proclaim '(function multi-compare (symbol list boolean)))
  1335. (defun multi-compare (predicate args not-p)
  1336.   (let ((nargs (length args)))
  1337.     (cond ((< nargs 1) (values nil t))
  1338.       ((= nargs 1) `(progn ,@args t))
  1339.       ((= nargs 2)
  1340.        (if not-p
  1341.            `(if (,predicate ,(first args) ,(second args)) nil t)
  1342.            (values nil t)))
  1343.       (t
  1344.        (do* ((i (1- nargs) (1- i))
  1345.          (last nil current)
  1346.          (current (gensym) (gensym))
  1347.          (vars (list current) (cons current vars))
  1348.          (result 't (if not-p
  1349.                 `(if (,predicate ,current ,last)
  1350.                      nil ,result)
  1351.                 `(if (,predicate ,current ,last)
  1352.                      ,result nil))))
  1353.            ((zerop i)
  1354.         `((lambda ,vars ,result) . ,args)))))))
  1355.  
  1356.  
  1357. (def-source-transform = (&rest args) (multi-compare '= args nil))
  1358. (def-source-transform < (&rest args) (multi-compare '< args nil))
  1359. (def-source-transform > (&rest args) (multi-compare '> args nil))
  1360. (def-source-transform <= (&rest args) (multi-compare '> args t))
  1361. (def-source-transform >= (&rest args) (multi-compare '< args t))
  1362.  
  1363. (def-source-transform char= (&rest args) (multi-compare 'char= args nil))
  1364. (def-source-transform char< (&rest args) (multi-compare 'char< args nil))
  1365. (def-source-transform char> (&rest args) (multi-compare 'char> args nil))
  1366. (def-source-transform char<= (&rest args) (multi-compare 'char> args t))
  1367. (def-source-transform char>= (&rest args) (multi-compare 'char< args t))
  1368.  
  1369. (def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil))
  1370. (def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil))
  1371. (def-source-transform char-greaterp (&rest args) (multi-compare 'char-greaterp args nil))
  1372. (def-source-transform char-not-greaterp (&rest args) (multi-compare 'char-greaterp args t))
  1373. (def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t))
  1374.  
  1375.  
  1376. ;;; Multi-Not-Equal  --  Internal
  1377. ;;;
  1378. ;;;    This function does source transformation of N-arg inequality functions
  1379. ;;; such as /=.  This is similar to Multi-Compare in the <3 arg cases.  If
  1380. ;;; there are more than two args, then we expand into the appropriate n^2
  1381. ;;; comparisons only when speed is important.
  1382. ;;;
  1383. (proclaim '(function multi-not-equal (symbol list)))
  1384. (defun multi-not-equal (predicate args)
  1385.   (let ((nargs (length args)))
  1386.     (cond ((< nargs 1) (values nil t))
  1387.       ((= nargs 1) `(progn ,@args t))
  1388.       ((= nargs 2)
  1389.        `(if (,predicate ,(first args) ,(second args)) nil t))
  1390.       ((not (policy nil (>= speed space) (>= speed cspeed)))
  1391.        (values nil t))
  1392.       (t
  1393.        (collect ((vars))
  1394.          (dotimes (i nargs) (vars (gensym)))
  1395.          (do ((var (vars) next)
  1396.           (next (cdr (vars)) (cdr next))
  1397.           (result 't))
  1398.          ((null next)
  1399.           `((lambda ,(vars) ,result) . ,args))
  1400.            (let ((v1 (first var)))
  1401.          (dolist (v2 next)
  1402.            (setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
  1403.  
  1404. (def-source-transform /= (&rest args) (multi-not-equal '= args))
  1405. (def-source-transform char/= (&rest args) (multi-not-equal 'char= args))
  1406. (def-source-transform char-not-equal (&rest args) (multi-not-equal 'char-equal args))
  1407.  
  1408.  
  1409. ;;; Expand Max and Min into the obvious comparisons.
  1410. (def-source-transform max (arg &rest more-args)
  1411.   (if (null more-args)
  1412.       `(values ,arg)
  1413.       (once-only ((arg1 arg)
  1414.           (arg2 `(max ,@more-args)))
  1415.     `(if (> ,arg1 ,arg2)
  1416.          ,arg1 ,arg2))))
  1417. ;;;
  1418. (def-source-transform min (arg &rest more-args)
  1419.   (if (null more-args)
  1420.       `(values ,arg)
  1421.       (once-only ((arg1 arg)
  1422.           (arg2 `(min ,@more-args)))
  1423.     `(if (< ,arg1 ,arg2)
  1424.          ,arg1 ,arg2))))
  1425.  
  1426.  
  1427. ;;;; Converting N-arg arithmetic functions:
  1428. ;;;
  1429. ;;;    N-arg arithmetic and logic functions are associated into two-arg
  1430. ;;; versions, and degenerate cases are flushed.
  1431.  
  1432. ;;; Associate-Arguments  --  Internal
  1433. ;;;
  1434. ;;;    Left-associate First-Arg and More-Args using Function.
  1435. ;;;
  1436. (proclaim '(function associate-arguments (symbol t list) list))
  1437. (defun associate-arguments (function first-arg more-args)
  1438.   (let ((next (rest more-args))
  1439.     (arg (first more-args)))
  1440.     (if (null next)
  1441.     `(,function ,first-arg ,arg)
  1442.     (associate-arguments function `(,function ,first-arg ,arg) next))))
  1443.  
  1444. ;;; Source-Transform-Transitive  --  Internal
  1445. ;;;
  1446. ;;;    Do source transformations for transitive functions such as +.  One-arg
  1447. ;;; cases are replaced with the arg and zero arg cases with the identity.  If
  1448. ;;; Leaf-Fun is true, then replace two-arg calls with a call to that function. 
  1449. ;;;
  1450. (defun source-transform-transitive (fun args identity &optional leaf-fun)
  1451.   (declare (symbol fun leaf-fun) (list args))
  1452.   (case (length args)
  1453.     (0 identity)
  1454.     (1 `(values ,(first args)))
  1455.     (2 (if leaf-fun
  1456.        `(,leaf-fun ,(first args) ,(second args))
  1457.        (values nil t)))
  1458.     (t
  1459.      (associate-arguments fun (first args) (rest args)))))
  1460.  
  1461. (def-source-transform + (&rest args) (source-transform-transitive '+ args 0))
  1462. (def-source-transform * (&rest args) (source-transform-transitive '* args 1))
  1463. (def-source-transform logior (&rest args) (source-transform-transitive 'logior args 0))
  1464. (def-source-transform logxor (&rest args) (source-transform-transitive 'logxor args 0))
  1465. (def-source-transform logand (&rest args) (source-transform-transitive 'logand args -1))
  1466.  
  1467. (def-source-transform logeqv (&rest args)
  1468.   (if (evenp (length args))
  1469.       `(lognot (logxor ,@args))
  1470.       `(logxor ,@args)))
  1471.  
  1472. ;;; Note: we can't use source-transform-transitive for GCD and LCM because when
  1473. ;;; they are given one argument, they return it's absolute value.
  1474.  
  1475. (def-source-transform gcd (&rest args)
  1476.   (case (length args)
  1477.     (0 0)
  1478.     (1 `(abs (the integer ,(first args))))
  1479.     (2 (values nil t))
  1480.     (t (associate-arguments 'gcd (first args) (rest args)))))
  1481.  
  1482. (def-source-transform lcm (&rest args)
  1483.   (case (length args)
  1484.     (0 1)
  1485.     (1 `(abs (the integer ,(first args))))
  1486.     (2 (values nil t))
  1487.     (t (associate-arguments 'lcm (first args) (rest args)))))
  1488.  
  1489.  
  1490. ;;; Source-Transform-Intransitive  --  Internal
  1491. ;;;
  1492. ;;;    Do source transformations for intransitive n-arg functions such as /.
  1493. ;;; With one arg, we form the inverse.  With two args we pass.  Otherwise we
  1494. ;;; associate into two-arg calls.
  1495. ;;;
  1496. (proclaim '(function source-transform-intransitive (symbol list t) list))
  1497. (defun source-transform-intransitive (function args inverse)
  1498.   (case (length args)
  1499.     ((0 2) (values nil t))
  1500.     (1 `(,@inverse ,(first args)))
  1501.     (t
  1502.      (associate-arguments function (first args) (rest args)))))
  1503.  
  1504. (def-source-transform - (&rest args)
  1505.   (source-transform-intransitive '- args '(%negate)))
  1506. (def-source-transform / (&rest args)
  1507.   (source-transform-intransitive '/ args '(/ 1)))
  1508.  
  1509.  
  1510. ;;;; Apply:
  1511. ;;;
  1512. ;;;    We convert Apply into Multiple-Value-Call so that the compiler only
  1513. ;;; needs to understand one kind of variable-argument call.  It is more
  1514. ;;; efficient to convert Apply to MV-Call than MV-Call to Apply.
  1515.  
  1516. (def-source-transform apply (fun arg &rest more-args)
  1517.   (let ((args (cons arg more-args)))
  1518.     `(multiple-value-call ,fun
  1519.        ,@(mapcar #'(lambda (x)
  1520.              `(values ,x))
  1521.          (butlast args))
  1522.        (values-list ,(car (last args))))))
  1523.  
  1524.  
  1525. ;;;; FORMAT transform:
  1526.  
  1527. ;;; A transform for FORMAT, based on the original (courtesy of Skef.)
  1528. ;;;
  1529. (deftransform format ((stream control &rest args)
  1530.               ((or (member t) stream) simple-string &rest t))
  1531.   "convert to output primitives"
  1532.   (unless (constant-continuation-p control)
  1533.     (give-up "Control string is not a constant."))
  1534.   (let* ((control (continuation-value control))
  1535.      (end (length control))
  1536.      (penultimus (1- end))
  1537.      (stream-form (if (csubtypep (continuation-type stream)
  1538.                      (specifier-type 'stream))
  1539.               `(stream)
  1540.               ()))
  1541.      (arg-vars (mapcar #'(lambda (x)
  1542.                    (declare (ignore x))
  1543.                    (gensym))
  1544.                args))
  1545.      (args arg-vars)
  1546.      (index 0))
  1547.     (declare (simple-string control))
  1548.     (collect ((forms))
  1549.       (loop
  1550.     (let ((command-index (position #\~ control :start index)))
  1551.       (unless command-index
  1552.         ;; Write out the final part of the string.
  1553.         (forms `(write-string ,(subseq control index end)
  1554.                   ,@stream-form))
  1555.         (when args
  1556.           (compiler-warning "~R extra format argument~:P.  Ignoring..."
  1557.                 (length args))
  1558.           (forms `(progn ,@args)))
  1559.  
  1560.         (return `(lambda (stream control ,@arg-vars)
  1561.                (declare (ignorable stream control))
  1562.                ,@(forms)
  1563.                nil)))
  1564.  
  1565.       (when (= command-index penultimus)
  1566.         (abort-transform "FORMAT control string ends in a ~~: ~S"
  1567.                  control))
  1568.  
  1569.       ;; Non-command stuff gets write-string'ed out.
  1570.       (when (/= index command-index)
  1571.         (forms `(write-string
  1572.              ,(subseq control index command-index)
  1573.              ,@stream-form)))
  1574.       
  1575.       ;; Get the format directive.
  1576.       (flet ((next-arg ()
  1577.            (unless args
  1578.              (abort-transform "Missing FORMAT argument."))
  1579.            (pop args)))
  1580.         (forms
  1581.          (case (schar control (1+ command-index))
  1582.            ((#\b #\B) `(let ((*print-base* 2))
  1583.                  (princ ,(next-arg) ,@stream-form)))
  1584.            ((#\o #\O) `(let ((*print-base* 8))
  1585.                  (princ ,(next-arg) ,@stream-form)))
  1586.            ((#\d #\D) `(let ((*print-base* 10))
  1587.                  (princ ,(next-arg) ,@stream-form)))
  1588.            ((#\x #\X) `(let ((*print-base* 16))
  1589.                  (princ ,(next-arg) ,@stream-form)))
  1590.            ((#\a #\A) `(princ ,(next-arg) ,@stream-form))
  1591.            ((#\s #\S) `(prin1 ,(next-arg) ,@stream-form))
  1592.            (#\% `(terpri ,@stream-form))
  1593.            (#\& `(fresh-line ,@stream-form))
  1594.            (#\| `(write-char #\form ,@stream-form))
  1595.            (#\~ `(write-char #\~ ,@stream-form))
  1596.            (#\newline
  1597.         (let ((new-pos (position-if-not
  1598.                 #'lisp::whitespace-char-p
  1599.                 control
  1600.                 :start (+ command-index 2))))
  1601.           (if new-pos
  1602.               (setq command-index (- new-pos 2)))))
  1603.            (t
  1604.         (give-up)))))
  1605.  
  1606.       (setq index (+ command-index 2)))))))
  1607.